home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / EDWIN / BUFFER.S < prev    next >
Encoding:
Text File  |  1993-06-15  |  5.9 KB  |  171 lines
  1. ;;;
  2. ;;;    Copyright (c) 1985 Massachusetts Institute of Technology
  3. ;;;
  4. ;;;    This material was developed by the Scheme project at the
  5. ;;;    Massachusetts Institute of Technology, Department of
  6. ;;;    Electrical Engineering and Computer Science.  Permission to
  7. ;;;    copy this software, to redistribute it, and to use it for any
  8. ;;;    purpose is granted, subject to the following restrictions and
  9. ;;;    understandings.
  10. ;;;
  11. ;;;    1. Any copy made of this software must include this copyright
  12. ;;;    notice in full.
  13. ;;;
  14. ;;;    2. Users of this software agree to make their best efforts (a)
  15. ;;;    to return to the MIT Scheme project any improvements or
  16. ;;;    extensions that they make, so that these may be included in
  17. ;;;    future releases; and (b) to inform MIT of noteworthy uses of
  18. ;;;    this software.
  19. ;;;
  20. ;;;    3.  All materials developed as a consequence of the use of
  21. ;;;    this software shall duly acknowledge such use, in accordance
  22. ;;;    with the usual standards of acknowledging credit in academic
  23. ;;;    research.
  24. ;;;
  25. ;;;    4. MIT has made no warrantee or representation that the
  26. ;;;    operation of this software will be error-free, and MIT is
  27. ;;;    under no obligation to provide any services, by way of
  28. ;;;    maintenance, update, or otherwise.
  29. ;;;
  30. ;;;    5.  In conjunction with products arising from the use of this
  31. ;;;    material, there shall be no use of the name of the
  32. ;;;    Massachusetts Institute of Technology nor of any adaptation
  33. ;;;    thereof in any advertising, promotional, or sales literature
  34. ;;;    without prior written consent from MIT in each case.
  35. ;;;
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37. ;;;
  38. ;;;     Modified by Texas Instruments Inc 8/15/85
  39. ;;;
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41.  
  42. ;;;; Buffer Abstraction
  43.  
  44. (define-named-structure "Buffer"
  45.   name
  46.   group
  47.   point
  48.   mark-ring
  49.   modified?
  50.   windows
  51.   cursor-y
  52.   pathname
  53.   truename
  54.   writeable?
  55.   alist)
  56.  
  57. (define (make-buffer name)
  58.   (let ((group (region-group (string->region ""))))
  59.     (let ((buffer (%make-buffer)))
  60.       (vector-set! buffer buffer-index:name name)
  61.       (vector-set! buffer buffer-index:group group)
  62.       (set-buffer-point! buffer (%group-start group))
  63.       (vector-set! buffer buffer-index:mark-ring (make-ring 10))
  64.       (ring-push! (buffer-mark-ring buffer) (%group-start group))
  65.       (vector-set! buffer buffer-index:modified? #F)
  66.       (vector-set! buffer buffer-index:windows '())
  67.       (vector-set! buffer buffer-index:cursor-y #F)
  68.       (vector-set! buffer buffer-index:pathname #F)
  69.       (vector-set! buffer buffer-index:truename #F)
  70.       (vector-set! buffer buffer-index:writeable? #T)
  71.       (vector-set! buffer buffer-index:alist '())
  72.       (let ((daemon (make-buffer-modification-daemon buffer)))
  73.     (add-group-insert-daemon! group daemon)
  74.     (add-group-delete-daemon! group daemon))
  75.       buffer)))
  76.  
  77.  
  78. (define (buffer-region buffer)
  79.   (group-region (buffer-group buffer)))
  80.  
  81. (define (buffer-start buffer)
  82.   (%group-start (buffer-group buffer)))
  83.  
  84. (define (buffer-end buffer)
  85.   (%group-end (buffer-group buffer)))
  86.  
  87. (define (buffer-modeline-event! buffer type)
  88.   (define (loop windows)
  89.     (if (not (null? windows))
  90.     (begin (window-modeline-event! (car windows) type)
  91.            (loop (cdr windows)))))
  92.   (loop (buffer-windows buffer)))
  93.  
  94. (define (add-buffer-window! buffer window)
  95.   (vector-set! buffer buffer-index:windows
  96.            (cons window (vector-ref buffer buffer-index:windows))))
  97.  
  98. (define (set-buffer-cursor-y! buffer cursor-y)
  99.   (vector-set! buffer buffer-index:cursor-y cursor-y))
  100.  
  101. (define (set-buffer-name! buffer name)
  102.   (vector-set! buffer buffer-index:name name)
  103.   (buffer-modeline-event! buffer 'BUFFER-NAME))
  104.  
  105.  
  106. (define (set-buffer-pathname! buffer pathname)
  107.   (vector-set! buffer buffer-index:pathname pathname)
  108.   (buffer-modeline-event! buffer 'BUFFER-PATHNAME))
  109.  
  110. (define (set-buffer-truename! buffer truename)
  111.   (vector-set! buffer buffer-index:truename truename)
  112.   (buffer-modeline-event! buffer 'BUFFER-TRUENAME))
  113.  
  114. (define (set-buffer-point! buffer mark)
  115.   ;; Each window has its own point, so instead of signalling a point
  116.   ;; change from here, the window's point is changed and it tells
  117.   ;; the buffer about it.
  118.   (vector-set! buffer buffer-index:point
  119.                       (if (mark-left-inserting? mark)
  120.                           mark
  121.                           (%make-mark (mark-line mark) 
  122.                                       (mark-position mark) #T))))
  123.  
  124. (define ((make-buffer-modification-daemon buffer) . args)
  125.   (buffer-modified! buffer)
  126.   #F)
  127.  
  128. (define (buffer-not-modified! buffer)
  129.   (set-buffer-modified! buffer #F))
  130.  
  131. (define (buffer-modified! buffer)
  132.   (set-buffer-modified! buffer #T))
  133.  
  134. (define (set-buffer-modified! buffer sense)
  135.   (vector-set! buffer buffer-index:modified? sense)
  136.   (buffer-modeline-event! buffer 'BUFFER-MODIFIED))
  137.  
  138. (define (buffer-read-only? buffer)
  139.   (group-read-only? (buffer-group buffer)))
  140.  
  141. (define (set-buffer-writeable! buffer)
  142.   (set-group-writeable! (buffer-group buffer))
  143.   (vector-set! buffer buffer-index:writeable? #T)
  144.   (buffer-modeline-event! buffer 'BUFFER-MODIFIABLE))
  145.  
  146. (define (set-buffer-file-read-only! buffer)
  147.   (set-group-writeable! (buffer-group buffer))
  148.   (vector-set! buffer buffer-index:writeable? #F)
  149.   (buffer-modeline-event! buffer 'BUFFER-MODIFIABLE))
  150.  
  151. (define (set-buffer-read-only! buffer)
  152.   (set-group-read-only! (buffer-group buffer))
  153.   (vector-set! buffer buffer-index:writeable? #F)
  154.   (buffer-modeline-event! buffer 'BUFFER-MODIFIABLE))
  155.  
  156. ;;; Not used currently so commented out
  157.  
  158. ;;;(define (with-read-only-defeated mark thunk)
  159. ;;;  (let ((group (mark-group mark)))
  160. ;;;    (define read-only?)
  161. ;;;    (dynamic-wind (lambda ()
  162. ;;;            (set! read-only? (group-read-only? group))
  163. ;;;            (if read-only?
  164. ;;;            (set-group-writeable! group)))
  165. ;;;          thunk
  166. ;;;          (lambda ()
  167. ;;;            (if read-only?
  168. ;;;            (set-group-read-only! group))))))
  169. ;;;
  170. ;;;
  171.